# Jasmin.pm -*- Perl -*-
#
# Copyright (C) 1999, Bradley M. Kuhn, All Rights Reserved.
#
# You may distribute under the terms of either the GNU General Public License
# or the Artistic License, as specified in the LICENSE file that was shipped
# with this distribution.
# "Forget regret / or life is yours to miss /
# No other road / No other way / No day but today."
# -- Mimi, "Another Day", _RENT_
package B::JVM::Jasmin;
use 5.000562;
use strict;
use warnings;
require Exporter;
use AutoLoader qw(AUTOLOAD);
=head1 NAME
B::JVM::Jasmin - Perl Backend module for generating JVM code via Jasmin Assembler
=head1 SYNOPSIS
use B::JVM::Jasmin;
compile(KEEP_INTERMEDIATE_FILES_FLAG, [MAIN_CLASS_NAME]);
OR
perl -MO=JVM::Jasmin,KEEP_INTERMEDIATE_FILES_FLAG, [MAIN_CLASS_NAME] file.plx
=head1 DESCRIPTION
The B::JVM::Jasmin module is a Perl backend module that generates Jasmin
assembler code (which can then be compiled into JVM code with jasmin(1)) for
a Perl program.
=head1 AUTHOR
Bradley M. Kuhn, bkuhn@ebb.org, http://www.ebb.org/bkuhn
=head1 COPYRIGHT
Copyright (C) 1999, Bradley M. Kuhn, All Rights Reserved.
=head1 LICENSE
You may distribute under the terms of either the GNU General Public License
or the Artistic License, as specified in the LICENSE file that was shipped
with this distribution.
=head1 SEE ALSO
perl(1), jasmin(1).
=head1 DETAILED DOCUMENTATION
=cut
###############################################################################
=head2 B::JVM::Jasmin Package Variables
=over
=item $VERSION
Version number of B::JVM::Jasmin
=item @ISA
Canonical @ISA array, currently only derives from Exporter
=item @EXPORT
Canonical @EXPORT array
=item @EXPORT_OK
Canonical @EXPORT_OK array
=item $STATE
Reference to a B::JVM::Jasmin::CompileState object for the current state of
this compiler
=back
=cut
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $STATE);
@ISA = qw(Exporter);
$VERSION = '0.02';
@EXPORT = qw();
@EXPORT_OK = qw();
$STATE = undef;
=head2 Modules used by B::JVM::Jasmin
=over
=item B
Of course, we must use the B module to overide its functions and interface
with O.
=back
=cut
use B qw(OPf_MOD OPf_KIDS main_root peekop cstring);
#qw(main_root walkoptree_slow);
use Carp;
use B::JVM::Jasmin::CompileState;
###############################################################################
=head2 Methods in B::JVM::Jasmin
=over
=cut
#-----------------------------------------------------------------------------
=item B::JVM::Jasmin::compile
usage: B::JVM::Jasmin::compile(KEEP_INTERMEDIATE_FILES_FLAG, [MAIN_CLASS_NAME])
This is the default method that O.pm will call when this backend is used.
The first argument is a flag that indicates whether or not to keep the
intermediate temporary files that are generated by the compilation process. The second argument
=cut
sub compile {
$STATE = { keepIntermediateFiles => shift };
my $mainClassName = shift;
$STATE->{mainClassName} = $mainClassName if defined $mainClassName;
$STATE = new B::JVM::Jasmin::CompileState($STATE);
return sub {
# Start up the beginning of of the main class.
my $curMethod = "main([Ljava/lang/String;)V";
my $emit = $STATE->emit("main");
$STATE->setCurrentPackage("main");
$STATE->setCurrentMethod($curMethod);
$emit->methodStart($STATE->getCurrentMethod(), "static public");
# First, we must push the STATE_MARK, which will stay here until the end
$emit->getstatic($curMethod, "org/perl/internals/StackElement/STATE_MARK",
"Lorg/perl/internals/StackElement;");
# Walk the OP tree.
&WalkOPTree(&main_root, 0);
# Clean up and clear things out
ClearOperandStackToStateMark($emit, $curMethod);
$emit->returnVoid($curMethod);
$emit->methodEnd($curMethod, "DEBUG");
$STATE->clearCurrentMethod();
};
}
#-----------------------------------------------------------------------------
=item B::JVM::Jasmin::WalkOPTree
usage: B::JVM::Jasmin::compile($op, $level)
This method walks the op-tree and does pre and post processing on the op
codes. In some cases, the pre-processing will call WalkOPTree for any
sub-ops that exist.
=cut
sub WalkOPTree {
my($op, $level) = @_;
$op->JVMJasminPre($level);
$op->JVMJasminPost($level);
}
#-----------------------------------------------------------------------------
=item B::OP::JVMJasminPre
This method handles pre-processing on plain OPs. Note that for all these
OPs, there are no recursive calls to WalkOPTree, since plain OPs should
never have sub-OPs (I think :).
The following OPs are currently supported:
=over
=cut
sub B::OP::JVMJasminPre {
my ($op, $level) = @_;
my $name = $op->name();
if ($name eq "enter") {
=item enter
Currently, nothing is done on an "enter" OP. This may change in the future,
but I haven't seen a use for them (yet :).
=cut
} elsif ($name eq "pushmark") {
=item pushmark
On an "pushmark" OP, the LIST_MARK is pushed onto the JVM operand stack.
This indicates to other OPs that expect a list that the list ends here.
=cut
my $curMethod = $STATE->getCurrentMethod();
my $emit = $STATE->emit();
$emit->comment($curMethod, "Pushing the list mark");
$emit->getstatic($curMethod, "org/perl/internals/StackElement/LIST_MARK",
"Lorg/perl/internals/StackElement;");
} elsif ($name eq "null") {
=item null
A empty operation. Just send a "nop".
=cut
my $curMethod = $STATE->getCurrentMethod();
my $emit = $STATE->emit();
$emit->nop($curMethod);
} else {
print STDERR "OP_UNSUPPORTED: $name\n";
}
}
=back
=cut
#-----------------------------------------------------------------------------
=item B::OP::JVMJasminPost
Currently, there is no post processing done on plain OPs.
=cut
sub B::OP::JVMJasminPost {
my ($op, $level) = @_;
my $name = $op->name();
}
#-----------------------------------------------------------------------------
=item B::LISTOP::JVMJasminPre
Pre-processing on LISTOPs requires that any we recursively call
C<WalkOPTree>, since LISTOPs can have children.
The following LISTOPs are currently supported:
=over
=cut
sub B::LISTOP::JVMJasminPre {
my ($op, $level) = @_;
my $name = $op->name();
if ($name eq "leave") {
=item leave
A "leave" LISTOP will be the parent of a number of OPs. Therefore, we
process all the sub-OPs I<in order> on the pre-processing step.
=cut
if ($op->flags & &OPf_KIDS) {
for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
WalkOPTree($kid, $level + 1);
}
}
} elsif ($name eq "print") {
=item print
For a "print" LISTOP, we need to process the kids in reverse order, save
pushing the C<LIST_MARK>, which must happen first (the "print"
post-processing depends on the mark being there). As in many instances,
Perl appears to its own stack like a queue at times, and this causes
problems, since we are using the JVM operand stack. In other words, for a
"print" LISTOP, the Perl stack looks like this (left is top):
LIST_MARK, "1", "2\n"
However, this would print the string "12\n", not "2\n1". It's as if Perl
first finds the mark, and then processes from the mark to the end of the
stack as a queue! (This behavior is probably documented somewhere else, but
I just discovered it serendipitously (perhaps I should read documentation
more :)). So, to process a "print" statement, we grab the "pushmark" OP
first, process that, and then call C<WalkOPTree> recursively in I<reverse>
for the rest of the sub-OPs.
=cut
if ($op->flags & &OPf_KIDS) {
my $pushmark = $op->first;
# "pushmark" has to be the first OP for "print"
croak("expected a \"pushmark\" command but got: " . $pushmark->name())
if ($pushmark->name() ne "pushmark");
WalkOPTree($pushmark, $level + 1);
my @args = ();
for (my $arg = $pushmark->sibling; $$arg; $arg = $arg->sibling) {
unshift(@args, $arg);
}
foreach my $arg (@args) {
WalkOPTree($arg, $level + 1);
}
}
} elsif ($name eq "list") {
=item list
On a "list" LISTOP, there is no need to "pushmark" (I think :). When the
"list" LISTOP completes (at least from analyzing perl -Dts output) the mark
simply disappears. It doesn't appear to be there for any other operation
but the "list" LISTOP itself. If this isn't correct, this code will need to
be corrected.
In addition, the list is reversed on the JVM operand stack, just as is done
with the "print" LISTOP.
No post-processing is needed (I think :), because the "list" LISTOP just
sets up arguments for another OP.
=cut
if ($op->flags & &OPf_KIDS) {
my $pushmark = $op->first;
croak("expected a \"pushmark\" command but got: " . $pushmark->name())
if ($pushmark->name() ne "pushmark");
# Note we ignore the pushmark itself, and reverse the list on the
# stack--- This may be a problem. I don't know where else "list" is
# used. I found this behavior worked for stuff such as:
# print qw/H e l l o W o r l d/, "\n";
my @args = ();
for (my $arg = $pushmark->sibling; $$arg; $arg = $arg->sibling) {
unshift(@args, $arg);
}
foreach my $arg (@args) {
WalkOPTree($arg, $level + 1);
}
}
} elsif ($name eq "scope") {
=item scope
A "scope" LISTOP will be the parent of a number of OPs. Therefore, we
process all the sub-OPs I<in order> on the pre-processing step. May
processing may be needed, but I haven't discovered that it is yet.
=cut
if ($op->flags & &OPf_KIDS) {
for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
WalkOPTree($kid, $level + 1);
}
}
} else {
# Otherwise, this LISTOP needs no special ordering for its arguments,
# so they can be processed in order.
print STDERR "LIST_OP_UNSUPPORTED (processing kids in order): $name\n";
if ($$op && ($op->flags & &OPf_KIDS)) {
for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
WalkOPTree($kid, $level + 1);
}
}
}
}
=back
=cut
#-----------------------------------------------------------------------------
=item B::LISTOP::JVMJasminPost
Post-processing on LISTOPs is often required, since the sub-OPs often set up
arguments for processing.
The following LISTOPs currently have post-processing done:
=over
=cut
sub B::LISTOP::JVMJasminPost {
my ($op, $level) = @_;
my $name = $op->name();
my $curMethod = $STATE->getCurrentMethod();
my $emit = $STATE->emit();
if ($name eq "print") {
=item print
At this point, the pre-processing should have set up the arguments to
"print" on the JVM operand stack. A C<LIST_MARK> should mark the end of the
argument list on the JVM operand stack. A temporary variable is used to
store the return value of the print statement. It is and'ed with each
C<Functions.print> call return.
At the end, we build a C<StackElement> containing a C<Scalar> that
represents the final integer return value of the print statement.
=cut
my $startLabel = $emit->labelCreate($curMethod, "Start_print_loop");
my $finishLabel = $emit->labelCreate($curMethod, "End_print_loop");
my $retVal = $emit->methodCreateLocal($curMethod, "printRetValue", "I");
$emit->iconst($curMethod, 1);
$emit->istore($curMethod, $retVal);
$emit->labelSend($curMethod, $startLabel);
$emit->dup($curMethod);
$emit->invokevirtual($curMethod,
"org/perl/internals/StackElement/isListMark()Z");
$emit->ifne($curMethod, $finishLabel);
$emit->invokevirtual($curMethod,
"org/perl/internals/StackElement/" .
"getElement()Lorg/perl/internals/Scalar;");
$emit->invokestatic($curMethod,
"org/perl/internals/Functions/print" .
"(Lorg/perl/internals/Scalar;)I");
$emit->iload($curMethod, $retVal);
$emit->iand($curMethod);
$emit->istore($curMethod, $retVal);
$emit->gotoLabel($curMethod, $startLabel);
$emit->labelSend($curMethod, $finishLabel);
# Create a new stack element. dup it so it stays on the stack afterwords
$emit->newObject($curMethod, "org/perl/internals/StackElement");
$emit->dup($curMethod);
# Build the Scalar object that is needed
$emit->newObject($curMethod, "org/perl/internals/Scalar");
$emit->dup($curMethod);
$emit->iload($curMethod, $retVal);
$emit->invokespecial($curMethod, "org/perl/internals/Scalar/<init>(I)V");
$emit->invokespecial($curMethod,
"org/perl/internals/StackElement/<init>(Lorg/perl/internals/Scalar;)V");
# Free the retVal we no longer need it, the stack element we left on
# the stack represents it
$emit->methodFreeLocal($curMethod, $retVal);
}
}
=back
=cut
#-----------------------------------------------------------------------------
=item B::COP::JVMJasminPre
The following COPs are currently supported:
=over
=cut
sub B::COP::JVMJasminPre {
my ($op, $level) = @_;
my $name = $op->name();
my $curMethod = $STATE->getCurrentMethod();
my $emit = $STATE->emit();
if ($name eq "nextstate") {
=item nextstate
The "nextstate" COP clears the JVM operand stack. It finds the
C<STATE_MARK>, which indicates where and remaining data ends.
The C<STATE_MARK> is left on the stack.
=cut
ClearOperandStackToStateMark($emit, $curMethod, 1);
} else {
print STDERR "COP_UNSUPPORTED: $name\n";
}
}
=back
=cut
#-----------------------------------------------------------------------------
=item B::COP::JVMJasminPost
=cut
sub B::COP::JVMJasminPost {
my ($op, $level) = @_;
my $name = $op->name();
my $curMethod = $STATE->getCurrentMethod();
my $emit = $STATE->emit();
}
#-----------------------------------------------------------------------------
=item B::SVOP::JVMJasminPre
The following SVOPs are currently supported:
=over
=cut
sub B::SVOP::JVMJasminPre {
my ($op, $level) = @_;
my $name = $op->name();
my $curMethod = $STATE->getCurrentMethod();
my $emit = $STATE->emit();
if ($name eq "const") {
=item const
On a "const" SVOP, a C<Scalar> and a C<StackElement> to hold it must be
built. This is done by grabbing the C<cstring()> of the PV associated with
the SV we are given. I don't know if every SV supports the PV() method, my
thought is that it doesn't and this will need to be rewritten to handle
other types of SVs.
All this is done in pre-processing, no post-processing is necessary; the
C<StackElement> need only be left on the stack for whatever OP needs it.
=cut
my $stringValue = cstring($op->sv->PV());
my $scalarConstant = $emit->methodCreateLocal($curMethod, "scalarConstant",
"Lorg/perl/internals/Scalar");
# First, create a new Scalar and store it in $scalarConstant
$emit->newObject($curMethod, "org/perl/internals/Scalar");
$emit->dup($curMethod);
$emit->astore($curMethod, $scalarConstant);
# Initialize that scalar, setting the constant flag when we do
$emit->ldc($curMethod, $stringValue);
$emit->bipush($curMethod, 1);
$emit->invokespecial($curMethod,
"org/perl/internals/Scalar/<init>(Ljava/lang/String;Z)V");
# Create a stack element and dup it so it remains on stack at the end
$emit->newObject($curMethod, "org/perl/internals/StackElement");
$emit->dup($curMethod);
# Initalize the stack element with the scalar we were holding in
# $scalarConstant
$emit->aload($curMethod, $scalarConstant);
$emit->invokespecial($curMethod,
"org/perl/internals/StackElement/<init>(Lorg/perl/internals/Scalar;)V");
# We now don't need the $scalarConstant anymore, so we can free it
$emit->methodFreeLocal($curMethod, $scalarConstant);
} else {
print STDERR "SVOP_UNSUPPORTED: $name\n";
}
}
=back
=cut
#-----------------------------------------------------------------------------
=item B::SVOP::JVMJasminPost
No post-processing is currently required for SVOPs.
=over
=cut
sub B::SVOP::JVMJasminPost {
my ($op, $level) = @_;
my $name = $op->name();
}
=back
=cut
#-----------------------------------------------------------------------------
=item B::BINOP::JVMJasminPre
Pre-processing on BINOPs requires that any we recursively call
C<WalkOPTree>, for the two sub-ops
The following BINOPs are currently supported:
=over
=cut
sub B::BINOP::JVMJasminPre {
my ($op, $level) = @_;
my $name = $op->name();
my $curMethod = $STATE->getCurrentMethod();
my $emit = $STATE->emit();
if ($name eq "sassign") {
=item sassign
To pre-process an "sassign" BINOP, we need only process the two sub-OPs. We
do so B<in>, so that in post-processing, we can assume that the
left-hand-side of the assignment is first on the stack, and the
right-hand-side is the second down element on the stack.
The post-processing actually does the assignment.
=cut
$emit->comment($curMethod, "PRE: sassign BINOP");
my $count = 0;
for (my $arg = $op->first; $$arg; $arg = $arg->sibling) {
WalkOPTree($arg, $level + 1);
$count++;
}
croak("unknown count in contact in B::BINOP::JVMJasminPre, " .
"is $count and should be 2") unless ($count == 2);
} elsif ($name eq "concat") {
=item concat
To pre-process a "concat" BINOP, we need only process the two sub-OPs. We
do so B<in> order. Post processing would be easier if it was done in
reverse order (since the top of the JVM operand stack would be the result we
need to keep), but it is imperative we go in order for cascading operations
to have the proper semantics.
=cut
$emit->comment($curMethod, "PRE: concat BINOP");
my $count = 0;
for (my $arg = $op->first; $$arg; $arg = $arg->sibling) {
WalkOPTree($arg, $level + 1);
$count++;
}
croak("unknown count in contact in B::BINOP::JVMJasminPre, " .
"is $count and should be 2") unless ($count == 2);
} elsif ($name eq "seq" or $name eq "sne") {
=item seq and sne
To pre-process a "seq" and "sne" BINOPs, we need to process the two sub-OPs.
We do so B<in> order. Post processing would be easier if it was done in
reverse order (since the top of the JVM operand stack would be the result we
need to keep), but it is imperative we go in order for cascading operations
to have the proper semantics.
=cut
$emit->comment($curMethod, "PRE: $name BINOP");
my $count = 0;
for (my $arg = $op->first; $$arg; $arg = $arg->sibling) {
WalkOPTree($arg, $level + 1);
$count++;
}
croak("unknown count in contact in B::BINOP::JVMJasminPre, " .
"is $count and should be 2") unless ($count == 2);
} else {
print STDERR "BINOP_UNSUPPORTED: $name\n";
}
}
=back
=cut
#-----------------------------------------------------------------------------
=item B::BINOP::JVMJasminPost
Currently, post-processing occurs on the following BINOPs:
=over
=cut
sub B::BINOP::JVMJasminPost {
my ($op, $level) = @_;
my $name = $op->name();
my $curMethod = $STATE->getCurrentMethod();
my $emit = $STATE->emit();
if ($name eq "sassign") {
=item sassign
On post-processing, the "sassign" BINOP expects there to be two
C<StackElement>s on the JVM operand stack. The top is the left-hand-side of
the "sassign", and below that (on the operand stack) is the right-hand-side
of the "sassign". Both C<Scalar> quantities will be wrapped in
C<StackElements>.
So, both C<StackElement>s are converted into C<Scalar>. To do this, the
function C<TurnStackElementsToScalars> is called, and told to leave the
stack elements in an array. The array that is returned is used set up the
C<Scalar>s for assignment.
Then, to to perform the actual assignment, C<assignFromScalar> is used.
Finally, note as well that the left-hand-side C<StackElement> is saved, as
this should be the "return value" of the "sassign". It is left on the JVM
operand stack at the end.
=cut
$emit->comment($curMethod, "POST: sassign BINOP");
my $retVal = $emit->methodCreateLocal($curMethod, "retVal",
"Lorg/perl/internals/StackElement");
# Save the lhs StackElement in $retVal, so it will be there at the end
# of the assignment process
$emit->dup($curMethod);
$emit->astore($curMethod, $retVal);
my $array = TurnStackElementsToScalars($emit, $curMethod, 2, "ARRAY");
# Put left-hand-side Scalar on the stack
$emit->aload($curMethod, $array);
$emit->bipush($curMethod, 1);
$emit->aaload($curMethod);
# Put right-hand-side Scalar on the stack
$emit->aload($curMethod, $array);
$emit->bipush($curMethod, 0);
$emit->aaload($curMethod);
$emit->invokevirtual($curMethod,
"org/perl/internals/Scalar/assignFromScalar" .
"(Lorg/perl/internals/Scalar;)V");
# Leave lhs StackElement on the stack at the end
$emit->aload($curMethod, $retVal);
foreach my $localToFree ($array, $retVal) {
$emit->methodFreeLocal($curMethod, $localToFree);
}
} elsif ($name eq "concat") {
=item concat
On post-processing, the "concat" BINOP expects there to be two
C<StackElement>s on the JVM operand stack. The top is the right-operand of
the "concat", and below that (on the operand stack) is the left-operand of
the "concat". Both C<Scalar> quantities will be wrapped in
C<StackElements>.
So, both C<StackElement>s are converted into C<Scalar>. To do this, the
function C<TurnStackElementsToScalars> is called, and is told to leave the
stack elements in an array. The array that is returned is used set up the
C<Scalar>s for concatenation.
Then, to perform the actual concatenation, C<Scalar.concat> function is
used.
Finally, note as well that the left-operand C<StackElement> is saved, as
this should be the "return value" of the "concat". It is left on the JVM
operand stack at the end.
=cut
$emit->comment($curMethod, "POST: concat BINOP");
my $retVal = $emit->methodCreateLocal($curMethod, "retVal",
"Lorg/perl/internals/StackElement");
# Save the left-operand StackElement in $retVal, so it will be there at
# the end of the concat process. This requires some swapping around of
# the items, since the left-operand is the *second* thing, not the first
# on the JVM operand stack
$emit->swap($curMethod);
$emit->dup($curMethod);
$emit->astore($curMethod, $retVal);
$emit->swap($curMethod);
my $array = TurnStackElementsToScalars($emit, $curMethod, 2, "ARRAY");
# Put left-operand Scalar on the stack
$emit->aload($curMethod, $array);
$emit->bipush($curMethod, 0);
$emit->aaload($curMethod);
# Put right-operand Scalar on the stack
$emit->aload($curMethod, $array);
$emit->bipush($curMethod, 1);
$emit->aaload($curMethod);
$emit->invokevirtual($curMethod,
"org/perl/internals/Scalar/concat" .
"(Lorg/perl/internals/Scalar;)V");
# Leave now modified left-operand StackElement on the stack at the end
$emit->aload($curMethod, $retVal);
foreach my $localToFree ($array, $retVal) {
$emit->methodFreeLocal($curMethod, $localToFree);
}
} elsif ($name eq "seq" or $name eq "sne") {
=item seq and sne
On post-processing, the "seq" and "sne" BINOPs expect there to be two
C<StackElement>s on the JVM operand stack. The top is the right-operand of
the "seq", and below that (on the operand stack) is the left-operand of the
"seq". Both C<Scalar> quantities will be wrapped in C<StackElements>.
So, both C<StackElement>s are converted into C<Scalar>. To do this, the
function C<TurnStackElementsToScalars> is called, and is told to leave the
stack elements in an array. The array that is returned is used set up the
C<Scalar>s for comparison.
Then, to perform the actual comparison, C<Scalar.seq> function is used.
Then, we use that return value to create a new C<Scalar>, wrapped in a
C<StackElement>, which is left on the stack at the end.
=cut
$emit->comment($curMethod, "POST: seq BINOP");
my $retVal = $emit->methodCreateLocal($curMethod, "retVal",
"Lorg/perl/internals/Scalar");
my $array = TurnStackElementsToScalars($emit, $curMethod, 2, "ARRAY");
# Put left-operand Scalar on the stack
$emit->aload($curMethod, $array);
$emit->bipush($curMethod, 0);
$emit->aaload($curMethod);
# Put right-operand Scalar on the stack
$emit->aload($curMethod, $array);
$emit->bipush($curMethod, 1);
$emit->aaload($curMethod);
$emit->invokevirtual($curMethod, "org/perl/internals/Scalar/" . $name .
"(Lorg/perl/internals/Scalar;)Lorg/perl/internals/Scalar;");
# Leave now modified left-operand StackElement on the stack at the end
$emit->astore($curMethod, $retVal);
# We must wrap the returned scalar in a StackElement for the return from
# this expression
$emit->newObject($curMethod, "org/perl/internals/StackElement");
$emit->dup($curMethod);
$emit->aload($curMethod, $retVal);
$emit->invokespecial($curMethod,
"org/perl/internals/StackElement/<init>(Lorg/perl/internals/Scalar;)V");
# Free the $retVal local we used
$emit->methodFreeLocal($curMethod, $retVal);
}
}
=back
=cut
#-----------------------------------------------------------------------------
=item B::UNOP::JVMJasminPre
Pre-processing on UNOPs requires that any we recursively call
C<WalkOPTree>, for the two sub-ops
The following UNOPs are currently supported:
=over
=cut
sub B::UNOP::JVMJasminPre {
my ($op, $level) = @_;
my $name = $op->name();
my $curMethod = $STATE->getCurrentMethod();
my $emit = $STATE->emit();
=item null
On "null" UNOPs, we simply process the sub-OP. More interesting stuff
happens in the post-processing.
=cut
if ($name eq "null") {
$emit->comment($curMethod, "PRE: null UNOP");
WalkOPTree($op->first, $level + 1);
} else {
print STDERR "UNOP_UNSUPPORTED: $name\n";
}
}
=back
=cut
#-----------------------------------------------------------------------------
=item B::UNOP::JVMJasminPost
Post-processing on UNOPs is required because some flags needed to be
checked. The results of the UNOP's child may require manipulation based on
these flags.
The following UNOPs currently require post-processing:
=over
=cut
sub B::UNOP::JVMJasminPost {
my ($op, $level) = @_;
my $name = $op->name();
my $curMethod = $STATE->getCurrentMethod();
my $emit = $STATE->emit();
=item null
On a "null" UNOP, we need to check to see if the OPf_MOD flag is on. If it
is not, then we need to make a copy of the C<Scalar> result (wrapped in a
C<StackElement> on the stack. We canno inadvertently modify the l-value of
a variable, so we make the copy.
If OPf_MOD is on, we need an l-value on the stack anyway, so things can be
left alone.
=cut
if ($name eq "null") {
$emit->comment($curMethod, "POST: null UNOP");
unless ($op->flags & &OPf_MOD) {
# If we cannot modify this entity, we'll need to create a new one
# that can be modified safely.
# First, grab the scalar we had into a temporary.
my $scalarNoModify = $emit->methodCreateLocal($curMethod,
"scalarNoModify", "Lorg/perl/internals/Scalar");
$emit->invokevirtual($curMethod, "org/perl/internals/StackElement/" .
"getElement()Lorg/perl/internals/Scalar;");
$emit->astore($curMethod, $scalarNoModify);
# Create a new stack element. We'll use that for the final value. dup
# it now, because when we do the <init> later on, we'll loose the current
# one and we want to keep it on the stack
$emit->newObject($curMethod, "org/perl/internals/StackElement");
$emit->dup($curMethod);
# Create the new Scalar object that we will be able to modify
# dup it so we can leave it on the operand stack after initialization.
$emit->newObject($curMethod, "org/perl/internals/Scalar");
$emit->dup($curMethod);
$emit->aload($curMethod, $scalarNoModify);
# Initialize the new scalar, using the nonModifiable scalar as
# the source
$emit->invokespecial($curMethod, "org/perl/internals/Scalar/<init>" .
"(Lorg/perl/internals/Scalar;)V");
# Place the new scalar into the StackElement
$emit->invokespecial($curMethod,
"org/perl/internals/StackElement/<init>(Lorg/perl/internals/Scalar;)V");
# That scalar is now left on the stack because we dup'ed it...
$emit->methodFreeLocal($curMethod, $scalarNoModify);
}
}
}
=back
=cut
#-----------------------------------------------------------------------------
=item B::GVOP::JVMJasminPre
The following GVOPs are currently supported:
=over
=cut
sub B::GVOP::JVMJasminPre {
my ($op, $level) = @_;
my $name = $op->name();
my $curMethod = $STATE->getCurrentMethod();
my $emit = $STATE->emit();
=item gvsv
To pre-process a "gvsv" GVOP, we must find the correct C<Scalar> object.
First, the C<DEF_STASH> is put on the JVM operand stack. Then, if this is
not a variable in "main" namespace, we use that C<DEF_STASH> to find the
proper C<Stash> (this part not yet working FIXME). Once the required
C<Stash> is found, the proper C<GV> is obtained, using methods from the
C<Stash> class). The C<Scalar> is retrieved from that C<GV>. The C<Scalar>
is then wrapped in a C<StackElement> object.
=cut
if ($name eq "gvsv") {
my $stashName = $op->gv->STASH->NAME();
my $gvName = $op->gv->NAME();
# Create a new stack element. We'll use that for the final value. dup
# it now, because when we do the <init> later on, we'll loose the current
# one and we want to keep it on the stack
$emit->newObject($curMethod, "org/perl/internals/StackElement");
$emit->dup($curMethod);
$emit->getstatic($curMethod, "org/perl/internals/Stash/DEF_STASH",
"Lorg/perl/internals/Stash;");
if ($stashName ne "main") {
$emit->ldc($curMethod, cstring $stashName);
$emit->invokevirtual($curMethod,
"org/perl/internals/Stash/findNamespace" .
"(Ljava/lang/String;)Lorg/perl/internals/Stash;");
}
$emit->ldc($curMethod, cstring $gvName);
$emit->invokevirtual($curMethod,
"org/perl/internals/Stash/findGV" .
"(Ljava/lang/String;)Lorg/perl/internals/GV;");
$emit->invokevirtual($curMethod,
"org/perl/internals/GV/getScalar" .
"()Lorg/perl/internals/Scalar;");
$emit->invokespecial($curMethod,
"org/perl/internals/StackElement/<init>(Lorg/perl/internals/Scalar;)V");
} else {
print STDERR "GVOP_UNSUPPORTED: $name\n";
}
}
=back
=cut
#-----------------------------------------------------------------------------
=item B::GVOP::JVMJasminPost
Post-processing is not currently required on any GVOPs.
=over
=cut
sub B::GVOP::JVMJasminPost {
}
=back
=cut
#-----------------------------------------------------------------------------
=item B::LOGOP::JVMJasminPre
Pre-processing on LOGOPs requires that any we recursively call
C<WalkOPTree>, for the 3 sub-OPs.
The following LOGOPs are currently supported:
=over
=cut
sub B::LOGOP::JVMJasminPre {
my ($op, $level) = @_;
my $name = $op->name();
my $curMethod = $STATE->getCurrentMethod();
my $emit = $STATE->emit();
if ($name eq "cond_expr") {
=item cond_expr
For an "cond_expr" LOGOP, we should have exactly three sub-OPs. This is a
basic "if-else" structure (I think :). The first sub-OP will be the
condition, the second sub-OP will be the block that should be executed if
the condition is false, and the third is the block that should be executed if
the condition is true.
So, we process each OP, and surround it with the logic that is required to
carry out the conditional.
=cut
$emit->comment($curMethod, "PRE: cond_expr LOGOP");
my $conditionalOP = $op->first;
my $ifTrueOP = $conditionalOP->sibling;
my $ifFalseOP = $ifTrueOP->sibling;
my $falseBlockLabel = $emit->labelCreate($curMethod,
"CondExpr_False_Block");
my $condDoneLabel = $emit->labelCreate($curMethod, "CondExpr_Done");
# First, walk the OP tree of the conditional expression. At the end, we
# should have a StackElement on the stack that is the value of conditional
# expression
WalkOPTree($conditionalOP, $level + 1);
$emit->invokevirtual($curMethod,
"org/perl/internals/StackElement/" .
"getElement()Lorg/perl/internals/Scalar;");
# See if its true, if it is, continue along, if not goto false block
$emit->invokevirtual($curMethod, "org/perl/internals/Scalar/isTrue()Z");
$emit->ifeq($curMethod, $falseBlockLabel);
# Generate code for the true block
WalkOPTree($ifTrueOP, $level + 1);
$emit->gotoLabel($curMethod, $condDoneLabel);
# Generate code for the false block
$emit->labelSend($curMethod, $falseBlockLabel);
WalkOPTree($ifFalseOP, $level + 1);
# The end. :)
$emit->labelSend($curMethod, $condDoneLabel);
} else {
print STDERR "LOGOP_UNSUPPORTED: $name\n";
}
}
=back
=cut
#-----------------------------------------------------------------------------
=item B::LOGOP::JVMJasminPost
Currently, post-processing occurs on the following LOGOPs:
=over
=cut
sub B::LOGOP::JVMJasminPost {
my ($op, $level) = @_;
my $name = $op->name();
my $curMethod = $STATE->getCurrentMethod();
my $emit = $STATE->emit();
if ($name eq "") {
=item ""
=cut
}
}
=back
=cut
#-----------------------------------------------------------------------------
=item ClearOperandStackToStateMark
usage: C<ClearOperandStackToStateMark($emitter, $curMethod, $leaveStateMark);>
This subroutine emits the required code to clear the JVM operand stack until
a C<StackElement> which is a state mark is reached. It emits the code using
the given C<$emitter> and to the method, C<$curMethod>.
If C<$leaveStateMark> is defined and true, then the C<STATE_MARK> is left on
the stack, otherwise the C<STATE_MARK> is removed.
=cut
sub ClearOperandStackToStateMark {
my($emit, $curMethod, $leaveStateMark) = @_;
croak 'usage: ClearOperandStackToStateMark($emitter, $curMethod);'
unless (defined $emit and defined $curMethod and
ref($emit) eq "B::JVM::Jasmin::Emit");
my $startLabel = $emit->labelCreate($curMethod, "Start_clear_to_state_mark");
my $finishLabel = $emit->labelCreate($curMethod, "End_clear_to_state_mark");
$emit->labelSend($curMethod, $startLabel);
$emit->invokevirtual($curMethod,
"org/perl/internals/StackElement/isStateMark()Z");
$emit->ifne($curMethod, $finishLabel);
$emit->gotoLabel($curMethod, $startLabel);
$emit->labelSend($curMethod, $finishLabel);
if (defined $leaveStateMark and $leaveStateMark) {
$emit->getstatic($curMethod, "org/perl/internals/StackElement/STATE_MARK",
"Lorg/perl/internals/StackElement;");
}
}
#-----------------------------------------------------------------------------
=item TurnStackElementsToScalars
usage: C<TurnStackElementsToScalars($emitter, $curMethod, $count, $leaveArray);>
This subroutine emits the required code to take C<$count> C<StackElement>s
off the stack and turn them back into C<Scalar>s.
It is completely required, that this function be called only if the top
C<$count> elements on the JVM operand stack be C<StackElement> objects who
have valid elements.
To do this, an array of C<Scalar>s is built. A loop runs, getting the
C<Scalar> elements from the C<StackElement>s on the stack.
If C<$leaveArray> is defined and true, then the variable name of the array
is simply returned. The array variable returned as yet to be freed.
If C<$leaveArray> not defined or is false, then, another loop runs to push
all the C<Scalar>s back onto the stack I<in the same order>. The array
varable is not returned (an empty string is returned instead). The array
variable will be freed in this case.
=cut
sub TurnStackElementsToScalars {
my($emit, $curMethod, $count, $leaveArray) = @_;
croak('usage: TurnStackElementsToScalars($emitter, $curMethod, $count,' .
'[$leaveArray]);')
unless (defined $emit and defined $curMethod and
ref($emit) eq "B::JVM::Jasmin::Emit" and defined $count and
$count >= 0);
my $startFill = $emit->labelCreate($curMethod, "Start_array_fill");
my $startRepush = $emit->labelCreate($curMethod, "Start_scalar_repush");
my $counter = $emit->methodCreateLocal($curMethod, "counter", "I");
my $array = $emit->methodCreateLocal($curMethod, "scalarArray",
"[Lorg/perl/internals/Scalar");
my $scalar = $emit->methodCreateLocal($curMethod, "scalar",
"Lorg/perl/internals/Scalar");
# Store the number of elements in the array in $counter, and on stack for
# next operation
$emit->bipush($curMethod, $count);
$emit->dup($curMethod);
$emit->istore($curMethod, $counter);
# Build the array to use
$emit->anewarray($curMethod, "org/perl/internals/Scalar");
$emit->astore($curMethod, $array);
# first loop to get Scalar values into the array
$emit->labelSend($curMethod, $startFill);
$emit->iload($curMethod, $counter);
$emit->ifeq($curMethod, $startRepush);
$emit->iinc($curMethod, $counter, -1);
$emit->invokevirtual($curMethod, "org/perl/internals/StackElement/" .
"getElement()Lorg/perl/internals/Scalar;");
$emit->astore($curMethod, $scalar);
$emit->aload($curMethod, $array);
$emit->iload($curMethod, $counter);
$emit->aload($curMethod, $scalar);
$emit->aastore($curMethod);
$emit->gotoLabel($curMethod, $startFill);
# The array is filled, now go back and push all the Scalars back on the stack
my $finishRepush = $emit->labelCreate($curMethod, "End_scalar_repush");
$emit->labelSend($curMethod, $startRepush);
my $returnValue = $array;
unless (defined $leaveArray and $leaveArray) {
# get the array element on the stack
$emit->aload($curMethod, $array);
$emit->iload($curMethod, $counter);
$emit->iinc($curMethod, $counter, 1); # increment counter
$emit->bipush($curMethod, $count);
$emit->iload($curMethod, $counter);
$emit->isub($curMethod, $counter);
$emit->ifeq($curMethod, $finishRepush);
$emit->gotoLabel($curMethod, $startRepush);
$emit->labelSend($curMethod, $finishRepush);
$emit->methodFreeLocal($curMethod, $array);
$returnValue = "";
}
foreach my $localToFree ($counter, $scalar) {
$emit->methodFreeLocal($curMethod, $localToFree);
}
return $returnValue;
}
###############################################################################
1;
__END__
=back
=cut
# LocalWords: LISTOP pushmark OP WalkOPTree OPs